;
; creature in the world
;

(defgeneric world-view (w) )
(defgeneric world-view-print (w v))
(defgeneric world-action (w a))
(defvar *w*)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass world-line ()
  ((i :initform 5)
   (r :initform (random 2))
   (rset :initform (random 1024))))

(defmethod world-view ((w world-line))
  (with-slots (i r rset) w
      (let ((h (make-hash-table)))
	(loop for x from 1 to 10 
	   do (setf (gethash x h) (if (= x i) 1 0)))
	(loop for x from 11 to 20 
	   do (setf (gethash x h) r))
	(loop for x from 21 to 30 
	   do (setf (gethash x h) (if (= (- x 20) i) 1 0)))
	(loop for x from 31 to 40 
	   do (setf (gethash x h) (if (logbitp (- x 31) rset) 1 0)))
	(setf (gethash 41 h) 0)
	(setf (gethash 42 h) 1)
	h)))


(defmethod world-action ((w world-line) a)
  (with-slots (i r rset) w
    (setf 
     r (random 2) 
     rset (random 1024))
    (let* ((oldi i) 
	   (delta (case a (l -1) (r +1) (otherwise (error "wrong a"))))
	   (newi (force-range 1 10 (+ oldi delta))))
      (setf i newi))))
    

(defmethod world-view-print ((w world-line) v)
  (do* ((i 1 (1+ i))
	(vi (gethash i v) (gethash i v)))
       ((null vi))
    (format t "~a" vi))
    ;(if (zerop (mod i 10)) (format t "~%"q))))
  (format t "~%"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass world-line2 ()
  ((i :initform 5)
   (row :initform 1)
   (col :initform 1)))

(defmethod world-view ((w world-line2))
  (with-slots (i row col) w
      (let ((h (make-hash-table)))
	(loop for x from 1 to 10 
	   do (setf (gethash x h) (if (= x i) 1 0))) ; linear field - only indirectly controlled
	(loop for x from 11 to 20 
	   do (setf (gethash x h) 0))
	(loop for x from 21 to 36 
	   do (setf (gethash x h) (if (= (- x 21) (+ col (* 4 row))) 1 0))) ; square direct control field
	h)))

(defmethod world-view-print ((w world-line2) v)
  (do* ((i 1 (1+ i))
	(vi (gethash i v) (gethash i v)))
       ((null vi))
    (if (member i '(11 21 25 29 33))
	(format t " "))
    (format t "~a" vi))
    ;(if (zerop (mod i 10)) (format t "~%"q))))
  (format t "~%"))

(defmethod world-action ((w world-line2) a)
  (with-slots (i row col) w
    (cond 
      ((and (eq a 'up) (= row 0) (= col 0)) ; move linear field
       	(setf i (force-range 1 10 (1- i)) row 3 col 3)) ; (format t "line-left row ~a col ~a ~%" row col))
      ((and (eq a 'up) (= row 0) (= col 1)) ; move linear field
       	(setf i (force-range 1 10 (1+ i)) row 3 col 3)) ; (format t "line-right row ~a col ~a ~%" row col))
      (T
	; move square control field
       (setf row (force-range 0 3 (+ row (case a (up -1) (down 1) (otherwise 0)))))
       (setf col (force-range 0 3 (+ col (case a (left -1) (right 1) (otherwise 0)))))))))
      

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun force-range (minv maxv v)
  (max (min v maxv) minv))

(defun world-view-keys (v)
  (let ((x))
    (maphash #'(lambda (key val) (declare (ignore val)) (push key x)) v)
    x))

(defun cluster-graph (keys bind-func)
  (let ((all (copy-list keys))
	(used (make-hash-table))
	ret)
    (dolist (x all)
      (when (null (gethash x used))
	(setf (gethash x used) 1)
	(let ((curr (list x)))
	  (dolist (y all)
	    (when (and (null (gethash y used)) (funcall bind-func x y))
	      (push y curr)
	      (setf (gethash y used) 1)))
	  (push curr ret))))
    ret))

(defun cluster-count-states (vect)
  (do ((i 0 (1+ i))
       (c 0))
      ((>= i (array-dimension vect 0)) c)
    (when (not (zerop (aref vect i)))
      (incf c))))

(defun cluster-test-bind (views k1 k2)
  (let ((c1 (vector 0 0))
	(c2 (vector 0 0))
	(cmix (make-array 4 :initial-element 0)))
    (dolist (v views)
      (let ((v1 (gethash k1 v))
	    (v2 (gethash k2 v)))
	(incf (aref c1 v1))
	(incf (aref c2 v2))
	(incf (aref cmix (+ (* 2 v1) v2)))))
    (let ((s1 (cluster-count-states c1))
	  (s2 (cluster-count-states c2))
	  (smix (cluster-count-states cmix)))
     ; (format t "~a ~a ~a" s1 s2 smix))))
      (< smix (* s1 s2)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun example-on-world-line2 (times)
  (dotimes (x times) 
    (let ((a (nth (random 4) (list 'left 'right 'up 'down))))
      (format t "~7a" a)
      (world-action *w* a) 
      (world-view-print *w* (world-view *w*)))))

; (loop for i from 1 to 10 do  (world-action *w* (nth (random 2) 
;   (list 'left 'right 'up 'down))) collect (world-view *w*))

; (cluster-graph (world-view-keys (world-view *w*)) (lambda (x y) (cluster-test-bind *v* x y)))

; (dotimes (a 42) (format t "~a ~a ~%" (1+ a) (cluster-test-bind *v* 3 (1+ a))))